home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / XLISP 3.0a1 / FASL.LSP < prev    next >
Text File  |  1995-03-11  |  1KB  |  47 lines
  1. (define basic-load load)
  2.  
  3. (define (file-exists? name)
  4.   (let ((f (open-input-file name)))
  5.     (when f
  6.       (close-port f)
  7.       #t)))
  8.  
  9. (define (load name)
  10.   (let ((off (string-search "." name)))
  11.     (if off
  12.       (let ((ext (substring name off)))
  13.         (if (string-ci=? ext ".fsl")
  14.           (load-fasl-file name)
  15.           (basic-load name)))
  16.       (let ((full-name (string-append name ".fsl")))
  17.         (if (file-exists? full-name)
  18.           (load-fasl-file full-name)
  19.           (basic-load (string-append name ".lsp")))))))
  20.  
  21. (define (compile-file name)
  22.   (let* ((iname (string-append name ".lsp"))
  23.          (oname (string-append name ".fsl"))
  24.          (if (open-input-file iname))
  25.          (of (open-output-file oname))
  26.          (sts #f))
  27.     (when (and if of)
  28.       (let loop ((expr (read if)))
  29.         (when (not (eof-object? expr))
  30.           (let ((compiled-expr (compile expr)))
  31.             (fasl-write-procedure compiled-expr of))
  32.           (loop (read if))))
  33.       (set! sts #t))
  34.     (when if (close-port if))
  35.     (when of (close-port of))
  36.     sts))
  37.  
  38. (define (load-fasl-file name)
  39.   (let ((if (open-input-file name)))
  40.     (when if
  41.       (let loop ((proc (fasl-read-procedure if)))
  42.         (when (not (eof-object? proc))
  43.           (proc)
  44.           (loop (fasl-read-procedure if))))
  45.       (close-port if)
  46.       #t)))
  47.